home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 21 / CU Amiga Magazine's Super CD-ROM 21 (1998)(EMAP Images)(GB)[!][issue 1998-04].iso / CUCD / Programming / PPCcforth / forth.dict < prev    next >
Text File  |  1985-12-27  |  18KB  |  1,043 lines
  1. PRIM EXECUTE        0    ( cfa -- <execute word> )
  2. PRIM LIT        1    ( push the next value to the stack )
  3. PRIM BRANCH        2    ( branch by offset in next word )
  4. PRIM 0BRANCH        3    ( branch if zero by off. in next word )
  5. PRIM (LOOP)        4    ( end of a <DO> )
  6. PRIM (+LOOP)        5    ( inc -- <end of a <DO> w/increment != 1 )
  7. PRIM (DO)        6    ( limit init -- <begin a DO loop> )
  8. PRIM I            7    ( get loop index <R> )
  9. PRIM DIGIT        8    ( c -- DIGIT 1 | 0 <convert digit> )
  10. PRIM (FIND)        9    ( s -- s 0 | s NFA 1 <find word s> )
  11. PRIM ENCLOSE        10    ( addr c -- addr next first last <not quite> )
  12. PRIM KEY        11    ( -- c <get next char from input> )
  13. PRIM (EMIT)        12    ( c -- <put char to output> )
  14. PRIM ?TERMINAL        13    ( see if op. interrupted <like w/^C> )
  15. PRIM CMOVE        14    ( src dest count -- <move words>)
  16. PRIM U*            15    ( unsigned multiply )
  17. PRIM U/            16    ( unsigned divide )
  18. PRIM AND        17    ( a b -- a&b )
  19. PRIM OR            18    ( a b -- a|b )
  20. PRIM XOR        19    ( a b -- a%b )
  21. PRIM SP@        20    ( -- sp )
  22. PRIM SP!        21    ( -- <store empty value to sp> )
  23. PRIM RP@        22    ( -- rp )
  24. PRIM RP!        23    ( -- <store empty value to rp> )
  25. PRIM ;S            24    ( -- <pop r stack <end colon def'n>> )
  26. PRIM LEAVE        25    ( -- <set index = limit for a loop> )
  27. PRIM >R            26    ( a -- <push a to r stack> )
  28. PRIM R>            27    ( -- a <pop a from r stack )
  29. PRIM 0=            28    ( a -- !a <logical not> )
  30. PRIM 0<            29    ( a -- a<0 )
  31. PRIM +            30    ( a b -- a+b )
  32. PRIM D+            31    ( ahi alo bhi blo -- a+bhi a+blo )
  33. PRIM MINUS        32    ( a -- -a )
  34. PRIM DMINUS        33    ( ahi alo -- <-a>hi <-a>lo )
  35. PRIM OVER        34    ( a b -- a b a )
  36. PRIM DROP        35    ( a -- )
  37. PRIM SWAP        36    ( a b -- b a )
  38. PRIM DUP        37    ( a -- a a )
  39. PRIM 2DUP        38    ( a b -- a b a b )
  40. PRIM +!            39    ( val addr -- < *addr += val > )
  41. PRIM TOGGLE        40    ( addr mask -- <*addr %= mask> )
  42. PRIM @            41    ( addr -- *addr )
  43. PRIM C@            42    ( addr -- *addr )
  44. PRIM 2@            43    ( addr -- *addr+1 *addr )
  45. PRIM !            44    ( val addr -- <*addr = val> )
  46. PRIM C!            45    ( val addr -- <*addr = val> )
  47. PRIM 2!            46    ( bhi blo addr -- <*addr=blo, *addr+1=bhi )
  48. PRIM DOCOL        47    ( goes into CF of : definitions )
  49. PRIM DOCON        48    ( goes into CF of constants )
  50. PRIM DOVAR        49    ( goes into CF of variables )
  51. PRIM DOUSE        50    ( goes into CF of user variables )
  52. PRIM -            51    ( a b -- a-b )
  53. PRIM =            52    ( a b -- a==b)
  54. PRIM !=            53    ( a b -- a!=b)
  55. PRIM <            54    ( a b -- a<b )
  56. PRIM ROT        55    ( a b c -- c a b )
  57. PRIM DODOES        56    ( place holder; this value goes into CF )
  58. PRIM DOVOC        57
  59. PRIM R            58    ( same as I, but must be a primitive )
  60. PRIM ALLOT        59    ( primitive because of mem. management )
  61. PRIM (BYE)        60    ( executes exit <pop[]>; )
  62. PRIM TRON        61    ( depth -- trace to this depth )
  63. PRIM TROFF        62    ( stop tracing )
  64. PRIM DOTRACE        63    ( trace once )
  65. PRIM (R/W)        64    ( BUFFER FLAG ADDR -- read if flag=1, write/0 )
  66. PRIM (SAVE)        65    ( Save current environment )
  67. PRIM (COLD)        66
  68.  
  69. ( end of primitives )
  70.  
  71. CONST 0 0
  72. CONST 1 1
  73. CONST 2 2
  74. CONST 3 3
  75. CONST -1 -1
  76. CONST BL 32        ( A SPACE, OR BLANK )
  77. CONST C/L 64
  78. CONST B/BUF 1024
  79. CONST B/SCR 1
  80. CONST #BUFF 5        ( IMPLEMENTATION DEPENDENT )
  81.  
  82. CONST WORDSIZE 1    ( EXTENSION: WORDSIZE IS THE NUMBER OF BYTES IN A WORD.
  83.               USUALLY, THIS IS TWO, BUT WITH PSEUDO-MEMORY
  84.               ADDRESSED AS AN ARRAY OF WORDS, IT'S ONE. )
  85.  
  86. CONST FIRST 0        ( ADDRESS OF THE FIRST BUFFER AND END OF BUFFER SPACE )
  87. CONST LIMIT 0        ( the reader fills these in with INITR0 and DPBASE )
  88.  
  89. USER S0        24
  90. USER R0        25
  91. USER TIB    26
  92. USER WIDTH    27
  93. USER WARNING    28
  94. USER FENCE    29
  95. USER DP        30
  96. USER VOC-LINK    31
  97. USER BLK    32
  98. USER IN        33
  99. USER ERRBLK    34
  100. USER ERRIN    35
  101. USER OUT    36
  102. USER SCR    37
  103. USER OFFSET    38
  104. USER CONTEXT    39
  105. USER CURRENT    40
  106. USER STATE    41
  107. USER BASE    42
  108. USER DPL    43
  109. USER FLD    44
  110. USER CSP    45
  111. USER R#        46
  112. USER HLD    47
  113.  
  114. VAR USE 0        ( These two are filled in by COLD )
  115. VAR PREV 0        ( to the same as the constant FIRST )
  116. CONST SEC/BLK 1
  117.  
  118. : EMIT
  119.   (EMIT)
  120.   1 OUT +! ;
  121.  
  122. : CR
  123.   LIT 13 EMIT
  124.   LIT 10 EMIT
  125.   0 OUT ! ;
  126.  
  127. : NOP ;    ( DO-NOTHING )
  128.  
  129. : +ORIGIN ;    ( ADD ORIGIN OF SYSTEM; IN THIS CASE, 0 )
  130.  
  131. : 1+
  132.   1 + ;
  133.  
  134. : 2+
  135.   2 + ;
  136.  
  137. : 1-
  138.   1 - ;
  139.  
  140. : ++        ( ADDR -- <INCREMENTS VAL AT ADDR> )
  141.   1 SWAP +! ;    ( MY OWN EXTENSION )
  142.  
  143. : --        ( ADDR -- <DECREMENTS VAL AT ADDR> )
  144.   -1 SWAP +! ;    ( MY OWN EXTENSION )
  145.  
  146. : HERE        ( -- DP )
  147.   DP @ ;
  148.  
  149. : ,        ( V -- <PLACES V AT DP AND INCREMENTS DP>)
  150.   HERE !
  151.   WORDSIZE ALLOT ;    ( CHANGE FROM MODEL FOR WORDSIZE )
  152.  
  153. : C,        ( C -- <COMPILE A CHARACTER. SAME AS , WHEN WORDSIZE=1> )
  154.   HERE C!
  155.   1 ALLOT ;
  156.  
  157. : U<        ( THIS IS TRICKY. )
  158.     2DUP XOR 0<    ( SIGNS DIFFERENT? )
  159.     0BRANCH U1    ( NO: GO TO U1 )
  160.     DROP 0< 0=    ( YES; ANSWER IS [SECOND > 0] )
  161.     BRANCH U2    ( SKIP TO U2 <END OF WORD> )
  162. LABEL U1
  163.     - 0<    ( SIGNS ARE THE SAME. JUST SUBTRACT
  164.           AND TEST NORMALLY )
  165. LABEL U2
  166.     ;
  167.  
  168. : >        ( CHEAP TRICK )
  169.   SWAP < ;
  170.  
  171. : <>        ( NOT-EQUAL )
  172.   != ;
  173.  
  174. : SPACE        ( EMIT A SPACE )
  175.   BL EMIT
  176. ;
  177.  
  178. : -DUP        ( V -- V | V V <DUPLICATE IF V != 0> )
  179.   DUP
  180.   0BRANCH DDUP1    ( SKIP TO END IF IT WAS ZERO )
  181.   DUP
  182. LABEL DDUP1
  183. ;
  184.  
  185. : TRAVERSE    ( A DIR -- A <TRAVERSE A WORD FROM NFA TO LFA
  186.           <DIR = 1> OR LFA TO NFA <DIR = -1> )
  187.     SWAP
  188. LABEL T1
  189.     OVER    ( BEGIN )
  190.     +
  191.     LIT 0x7F OVER C@ <    ( HIGH BIT CLEAR? )
  192.     0BRANCH T1        ( UNTIL )
  193.     SWAP DROP ;
  194.  
  195. : LATEST        ( NFA OF LAST WORD DEFINED )
  196.   CURRENT @ @ ;
  197.  
  198. : LFA            ( GO FROM PFA TO LFA )
  199.   2 - ;            ( 2 IS WORDSIZE*2 )
  200.  
  201. : CFA            ( GO FROM PFA TO CFA )
  202.   WORDSIZE - ;
  203.  
  204. : NFA            ( GO FROM PFA TO NFA )
  205.   3 -            ( NOW AT LAST CHAR )
  206.   -1 TRAVERSE ;        ( 3 IS WORDSIZE*3 )
  207.  
  208. : PFA            ( GO FROM NFA TO PFA )
  209.   1 TRAVERSE        ( NOW AT LAST CHAR )
  210.   3 + ;            ( 3 IS WORDSIZE*3 )
  211.  
  212. : !CSP            ( SAVE CSP AT USER VAR CSP )
  213.   SP@ CSP ! ;
  214.  
  215. : (ABORT)
  216.   ABORT
  217. ;
  218.  
  219. : ERROR            ( N -- <ISSUE ERROR #N> )
  220.   WARNING @ 0<        ( WARNING < 0 MEANS <ABORT> )
  221.   0BRANCH E1
  222.   (ABORT)        ( IF )
  223. LABEL E1
  224.   HERE COUNT TYPE (.") "?"    ( THEN )
  225.   MESSAGE
  226.   SP!            ( EMPTY THE STACK )
  227.   BLK @ -DUP        ( IF LOADING, STORE IN & BLK )
  228.   0BRANCH E2
  229.   ERRBLK ! IN @ ERRIN !    ( IF )
  230. LABEL E2
  231.   QUIT            ( THEN )
  232. ;
  233.  
  234. : ?ERROR        ( F N -- <IF F, DO ERROR #N> )
  235.   SWAP
  236.   0BRANCH QERR1
  237.   ERROR            ( IF <YOU CAN'T RETURN FROM ERROR> )
  238. LABEL QERR1
  239.   DROP            ( THEN )
  240. ;
  241.  
  242. : ?COMP            ( GIVE ERR#17 IF NOT COMPILING )
  243.   STATE @ 0= LIT 17 ?ERROR
  244. ;
  245.  
  246. : ?EXEC            ( GIVE ERR#18 IF NOT EXECUTING )
  247.   STATE @ LIT 18 ?ERROR
  248. ;
  249.  
  250. : ?PAIRS        ( GIVE ERR#19 IF PAIRS DON'T MATCH )
  251.   - LIT 19 ?ERROR
  252. ;
  253.  
  254. : ?CSP            ( GIVE ERR#20 IF CSP & SP DON'T MATCH )
  255.   SP@ CSP @ - LIT 20 ?ERROR
  256. ;
  257.  
  258. : ?LOADING        ( GIVE ERR#21 IF NOT LOADING )
  259.   BLK @ 0= LIT 22 ?ERROR
  260. ;
  261.  
  262. : COMPILE        ( COMPILE THE CFA OF THE NEXT WORD TO DICT )
  263.   ?COMP
  264.   R> DUP        ( GET OUR RETURN ADDRESS )
  265.   WORDSIZE + >R        ( SKIP NEXT; ORIG. ADDR STILL ON TOS )
  266.   @ ,
  267. ;
  268.  
  269. : [            ( BEGIN EXECUTING )
  270.   0 STATE !
  271. ;*
  272.  
  273. : ]            ( END EXECUTING )
  274.   LIT 0xC0 STATE !
  275. ;*
  276.  
  277. : SMUDGE        ( TOGGLE COMPLETION BIT OF LATEST WORD )
  278.   LATEST        ( WHEN THIS BIT=1, WORD CAN'T BE FOUND )
  279.   LIT 0x20 TOGGLE
  280. ;
  281.  
  282. : :
  283.             ( DEFINE A WORD )
  284.   ?EXEC
  285.   !CSP
  286.   CURRENT @ CONTEXT !
  287.   CREATE ]        ( MAKE THE WORD HEADER AND BEGIN COMPILING )
  288.   (;CODE) DOCOL
  289. ;*
  290.  
  291. : ;            ( END A DEFINITION )
  292.   ?CSP            ( CHECK THAT WE'RE DONE )
  293.   COMPILE ;S        ( PLACE ;S AT THE END )
  294.   SMUDGE [        ( MAKE THE WORD FINDABLE AND BEGIN INTERPRETING )
  295. ;*
  296.  
  297. : CONSTANT
  298.   CREATE SMUDGE ,
  299.   (;CODE) DOCON
  300. ;
  301.  
  302. : VARIABLE
  303.   CONSTANT
  304.   (;CODE) DOVAR
  305. ;
  306.  
  307. : USER
  308.   CONSTANT
  309.   (;CODE) DOUSE
  310. ;
  311.  
  312. : HEX            ( GO TO HEXADECIMAL BASE )
  313.   LIT 0x10 BASE ! ;
  314.  
  315. : DECIMAL        ( GO TO DECIMAL BASE )
  316.   LIT 0x0A BASE !
  317. ;
  318.  
  319. : ;CODE                ( unused without an assembler )
  320.   ?CSP COMPILE (;CODE) [ NOP    ( "ASSEMBLER" might go where nop is )
  321. ;*
  322.  
  323. : (;CODE)            ( differs from the normal def'n )
  324.   R> @ @ LATEST PFA CFA !
  325. ;
  326.  
  327. : <BUILDS        ( UNSURE )
  328.   0 CONSTANT ;        ( NOTE CONSTANT != CONST )
  329.  
  330. : DOES>            ( UNSURE )
  331.   R> LATEST PFA !
  332.   (;CODE) DODOES
  333. ;
  334.  
  335. : COUNT            ( ADDR -- ADDR+1 COUNT )
  336.   DUP 1+ SWAP C@ ;    ( CONVERTS THE <STRING> ADDR TO A FORM SUITABLE
  337.               FOR "TYPE" )
  338.  
  339. : TYPE
  340.   -DUP
  341.   0BRANCH TYPE1
  342.   OVER + SWAP        ( GET START .. END ADDRS )
  343.   (DO)
  344. LABEL TYPE2
  345.     I C@ EMIT
  346.   (LOOP) TYPE2
  347.   BRANCH TYPE3
  348. LABEL TYPE1
  349.   DROP
  350. LABEL TYPE3
  351. ;
  352.  
  353. : -TRAILING        ( addr count -- addr count <count adjusted to
  354.               exclude trailing blanks> )
  355.   DUP 0 (DO)        ( DO )
  356. LABEL TRAIL1
  357.     OVER OVER + 1 - C@ BL -
  358.     0BRANCH TRAIL2
  359.     LEAVE BRANCH TRAIL3    ( IF )
  360. LABEL TRAIL2
  361.     1 -            ( ELSE )
  362. LABEL TRAIL3
  363.   (LOOP) TRAIL1        ( THEN LOOP )
  364. ;
  365.  
  366. : (.")            ( PRINT A COMPILED STRING )
  367.   R COUNT
  368.   DUP 1+ R> + >R TYPE
  369. ;
  370.  
  371. : ."            ( COMPILE A STRING IF COMPILING,
  372.               OR PRINT A STRING IF INTERPRETING )
  373.   LIT '"'
  374.   STATE @
  375.   0BRANCH QUOTE1
  376.   COMPILE (.") WORD HERE C@ 1+ ALLOT    ( IF )
  377.   BRANCH QUOTE2
  378. LABEL QUOTE1
  379.   WORD HERE COUNT TYPE            ( ELSE )
  380. LABEL QUOTE2
  381. ;*                    ( THEN )
  382.  
  383. : EXPECT        ( MODIFIED EXPECT lets UNIX input editing & echoing )
  384.             ( change EMIT to DROP below if not -echo )
  385.   OVER + OVER        ( start of input buffer is on top of stack )
  386.   DUP 0 SWAP C!        ( smack a zero at the start to catch empty lines )
  387.   (DO)            ( above is an added departure <read "hack"> )
  388. LABEL EXPEC1
  389.     KEY
  390.             ( Comment this region out if using stty cooked )
  391.     DUP LIT 8 = 0BRANCH EXPEC2
  392.     DROP DUP I = DUP R> 2 - + >R 0BRANCH EXPEC6
  393.     LIT 7 BRANCH EXPEC7
  394. LABEL EXPEC6
  395.     LIT 8        ( output for backspace )
  396. LABEL EXPEC7
  397.     BRANCH EXPEC3
  398.             ( End of region to comment out for stty cooked )
  399. LABEL EXPEC2
  400.     DUP LIT '\n' = 0BRANCH EXPEC4    ( IF )
  401.     LEAVE DROP BL 0 BRANCH EXPEC5
  402. LABEL EXPEC4                ( ELSE )
  403.     DUP
  404. LABEL EXPEC5                ( THEN )
  405.     I C! 0 I 1+ !
  406. LABEL EXPEC3
  407.     EMIT        ( use DROP here for stty echo, EMIT for -echo )
  408.     (LOOP) EXPEC1
  409.     DROP
  410. ;
  411.  
  412. : QUERY
  413.   TIB @            ( ADDRESS OF BUFFER )
  414.   B/BUF            ( SIZE OF BUFFER )
  415.   EXPECT        ( GET A LINE )
  416.   0 IN !        ( PREPARE FOR INTERPRET )
  417. ;
  418.  
  419. : {NUL}            ( THIS GETS TRANSLATED INTO A SINGLE NULL BYTE )
  420.   BLK @
  421.   0BRANCH NULL1
  422.   BLK ++ 0 IN !        ( IF )
  423.   BLK @ B/SCR 1 - AND 0=
  424.   0BRANCH NULL2
  425.   ?EXEC
  426.   R>            ( IF )
  427.   DROP
  428. LABEL NULL2
  429.   BRANCH NULL3        ( ENDIF ELSE )
  430. LABEL NULL1
  431.   R> DROP
  432. LABEL NULL3        ( ENDIF )
  433. ;*
  434.  
  435. : FILL            ( START COUNT VALUE -- <FILL COUNT WORDS, FROM START,
  436.               WITH VALUE )
  437.   SWAP -DUP
  438.   0BRANCH FILL1
  439.   SWAP ROT SWAP OVER C!    ( IF <NON-NULL COUNT> )
  440.   DUP 1+ ROT 1 -
  441.   CMOVE
  442.   BRANCH FILL2
  443. LABEL FILL1
  444.   DROP DROP
  445. LABEL FILL2
  446. ;
  447.  
  448. : ERASE            ( START COUNT -- <ZERO OUT MEMORY> )
  449.   0 FILL
  450. ;
  451.  
  452. : BLANKS        ( START COUNT -- <FILL WITH BLANKS> )
  453.   BL FILL
  454. ;
  455.  
  456. : HOLD            ( C -- <PLACE C AT --HLD> )
  457.   HLD -- HLD @ C!
  458. ;
  459.  
  460. : PAD            ( -- ADDR <OF PAD SPACE> )
  461.   HERE LIT 0x44 +
  462. ;
  463.  
  464. : WORD            ( C -- <GET NEXT WORD TO END OF DICTIONARY,
  465.               DELIMITED WITH C OR NULL )
  466.         ( LOADING PART OF THIS IS COMMENTED OUT )
  467.   BLK @ -DUP
  468.   0BRANCH W1
  469.       BLOCK        ( IF loading )
  470.       BRANCH W2 
  471. LABEL W1
  472.     TIB @        ( ELSE )
  473. LABEL W2        ( ENDIF )
  474.   IN @ + SWAP ENCLOSE    ( GET THE WORD )
  475.   HERE LIT 0x22 BLANKS    ( BLANK SPACE AFTER WORD )
  476.   IN +! OVER - >R R HERE C! + HERE 1+ R> CMOVE
  477. ;
  478.  
  479. : (NUMBER)
  480. LABEL NUM1
  481.   1+
  482.   DUP >R C@ BASE @ DIGIT
  483.   0BRANCH NUM2        ( WHILE )
  484.   SWAP BASE @ U* DROP
  485.   ROT BASE @ U* D+
  486.   DPL @ 1+
  487.   0BRANCH NUM3
  488.   DPL ++        ( IF )
  489. LABEL NUM3
  490.   R>            ( ENDIF )
  491.   BRANCH NUM1        ( REPEAT )
  492. LABEL NUM2
  493.   R>
  494. ;
  495.  
  496. : NUMBER
  497.   0 0 ROT DUP 1+ C@
  498.   LIT '-' = DUP >R + -1
  499. LABEL N1        ( BEGIN )
  500.   DPL ! (NUMBER) DUP C@ BL !=
  501.   0BRANCH N2        ( WHILE )
  502.   DUP C@ LIT '0' != 0 ?ERROR 0    ( . )
  503.   BRANCH N1        ( REPEAT )
  504. LABEL N2
  505.   DROP R>
  506.   0BRANCH N3        ( IF )
  507.   DMINUS
  508. LABEL N3        ( ENDIF )
  509. ;
  510.  
  511. : -FIND
  512.   BL WORD ( HERE CONTEXT @ @ <FIND> DUP 0= 0BRANCH FIND1 DROP )
  513.   HERE LATEST (FIND)
  514. ( LABEL FIND1 )
  515. ;
  516.  
  517. : ID.            ( NFA -- <PRINT ID OF A WORD > )
  518.   PAD LIT 0x5F BLANKS
  519.   DUP PFA LFA OVER - PAD SWAP CMOVE
  520.   PAD COUNT LIT 0x1F AND TYPE SPACE
  521. ;
  522.  
  523. : CREATE        ( MAKE A HEADER FOR THE NEXT WORD )
  524.   -FIND
  525.   0BRANCH C1
  526.   DROP NFA ID. LIT 4 MESSAGE SPACE    ( NOT UNIQUE )
  527. LABEL C1
  528.   HERE DUP C@ WIDTH @ MIN 1+ ALLOT    ( MAKE ROOM )
  529.   DUP LIT 0xA0 TOGGLE            ( MAKE IT UNFINDABLE )
  530.   HERE 1 - LIT 0x80 TOGGLE        ( SET HI BIT )
  531.   LATEST ,            ( DO LF )
  532.   CURRENT @ !            ( UPDATE FOR LATEST )
  533.   LIT 999 ,            ( COMPILE ILLEGAL VALUE TO CODE FIELD )
  534. ;
  535.  
  536. : [COMPILE]        ( COMPILE THE NEXT WORD, EVEN IF IT'S IMMEDIATE )
  537.   -FIND 0= 0 ?ERROR DROP CFA ,
  538. ;*
  539.  
  540. : LITERAL
  541.   STATE @
  542.   0BRANCH L1
  543.   COMPILE LIT ,
  544. LABEL L1
  545. ;*
  546.  
  547. : DLITERAL
  548.   STATE @
  549.   0BRANCH D1
  550.   SWAP LITERAL LITERAL
  551. LABEL D1
  552. ;*
  553.  
  554. : ?STACK        ( ERROR IF STACK OVERFLOW OR UNDERFLOW )
  555.   S0 @ SP@ U< 1 ?ERROR    ( SP > S0 MEANS UNDERFLOW )
  556.   SP@ TIB @ U< LIT 7 ?ERROR  ( SP < R0 MEANS OVERFLOW: THIS IS IMPLEMENTATION-
  557.                 DEPENDENT; I KNOW THAT THE CS IS JUST 
  558.                 ABOVE THE TIB. )
  559. ;
  560.  
  561. : INTERPRET
  562. LABEL I1
  563.   -FIND            ( BEGIN )
  564.   0BRANCH I2
  565.   STATE @ <        ( IF )
  566.   0BRANCH I3
  567.   CFA ,            ( IF )
  568.   BRANCH I4
  569. LABEL I3
  570.   CFA EXECUTE        ( ELSE )
  571. LABEL I4
  572.   ?STACK        ( ENDIF )
  573.   BRANCH I5
  574. LABEL I2
  575.   HERE NUMBER DPL @ 1+
  576.   0BRANCH I6
  577.   DLITERAL        ( IF )
  578.   BRANCH I7
  579. LABEL I6
  580.   DROP LITERAL        ( ELSE )
  581. LABEL I7
  582.   ?STACK        ( ENDIF ENDIF )
  583. LABEL I5
  584.   BRANCH I1        ( AGAIN )
  585. ;
  586.  
  587. : IMMEDIATE        ( MAKE MOST-RECENT WORD IMMEDIATE )
  588.   LATEST LIT 0x40 TOGGLE
  589. ;
  590.  
  591. ( *** These are commented out because we don't handle vocabularies ***
  592.  
  593. : VOCABULARY
  594.   <BUILDS LIT 0xA081 ,
  595.   CURRENT @ CFA , HERE VOC-LINK @ , VOC-LINK ! DOES>
  596.   WORDSIZE + CONTEXT !
  597. ;
  598.  
  599. : DEFINITIONS
  600.   CONTEXT @ CURRENT !
  601. ;
  602. *** End of commenting-out *** )
  603.  
  604. : (        ( COMMENT )
  605.   LIT ')'    ( CLOSING PAREN )
  606.   WORD
  607. ;*
  608.  
  609. : QUIT
  610.   0 BLK ! [
  611. LABEL Q1
  612.   RP! CR QUERY INTERPRET    ( BEGIN )
  613.   STATE @ 0=
  614.   0BRANCH Q2
  615.   (.") "OK"            ( IF )
  616. LABEL Q2
  617.   BRANCH Q1            ( ENDIF AGAIN )
  618. ;
  619.  
  620. : ABORT
  621.   SP! DECIMAL ?STACK CR
  622.   .CPU                ( PRINT THE GREETING )
  623.   ( FORTH )
  624.   QUIT
  625. ;
  626.  
  627. : COLD
  628.   (COLD)
  629.   VOC-LINK @ CONTEXT !        ( INITIALIZE CONTEXT )
  630.   CONTEXT @ CURRENT !        ( MAKE CONTEXT CURRENT )
  631.   FIRST USE !
  632.   FIRST PREV !
  633.   EMPTY-BUFFERS
  634.   1 WARNING !            ( USE SCREEN 4 FOR ERROR MESSAGES )
  635.   ABORT
  636. ;
  637.  
  638. : WARM
  639.   EMPTY-BUFFERS
  640.   ABORT
  641. ;
  642.  
  643. : S->D
  644.   DUP 0<
  645.   0BRANCH S2D1
  646.   -1            ( HIGH WORD IS ALL 1S )
  647.   BRANCH S2D2
  648. LABEL S2D1
  649.   0
  650. LABEL S2D2
  651. ;
  652.  
  653. : +-
  654.   0<
  655.   0BRANCH PM1
  656.   MINUS
  657. LABEL PM1
  658. ;
  659.  
  660. : D+-
  661.   0<
  662.   0BRANCH DPM1
  663.   DMINUS
  664. LABEL DPM1
  665. ;
  666.  
  667. : ABS
  668.   DUP +-
  669. ;
  670.  
  671. : DABS
  672.   DUP D+-
  673. ;
  674.  
  675. : MIN
  676.   2DUP >
  677.   0BRANCH MIN1
  678.   SWAP
  679. LABEL MIN1
  680.   DROP
  681. ;
  682.  
  683. : MAX
  684.   2DUP <
  685.   0BRANCH MAX1
  686.   SWAP
  687. LABEL MAX1
  688.   DROP
  689. ;
  690.  
  691. ( MATH STUFF )
  692.  
  693. : M*
  694.   2DUP XOR >R ABS SWAP ABS U* R> D+-
  695. ;
  696.  
  697. : M/
  698.   OVER >R >R DABS R ABS U/
  699.   R> R XOR +- SWAP
  700.   R> +- SWAP
  701. ;
  702.  
  703. : *        ( MULTIPLY, OF COURSE )
  704.   M* DROP
  705. ;
  706.  
  707. : /MOD
  708.   >R S->D R> M/
  709. ;
  710.  
  711. : /            ( DIVIDE <AND CONQUOR> )
  712.   /MOD SWAP DROP
  713. ;
  714.  
  715. : MOD
  716.   /MOD DROP
  717. ;
  718.  
  719. : */MOD
  720.   >R M* R> M/
  721. ;
  722.  
  723. : */
  724.   */MOD
  725.   SWAP DROP
  726. ;
  727.  
  728. : M/MOD
  729.   >R 0 R U/ R> SWAP >R U/ R>
  730. ;
  731.  
  732. ( END OF MATH STUFF )
  733.  
  734. : (LINE)        ( LINE SCR -- ADDR C/L )
  735.   >R C/L B/BUF */MOD R> B/SCR * + BLOCK +
  736.   C/L
  737. ;
  738.  
  739. : .LINE            ( LINE SCR -- )
  740.   (LINE) -TRAILING TYPE
  741. ;
  742.  
  743. : MESSAGE
  744.   WARNING @ 0BRANCH MSG1
  745.   -DUP 0BRANCH MSG2        ( message # 0 is no message at all )
  746.   LIT 4 OFFSET @ B/SCR / - .LINE SPACE ( messages are on screen 4 )
  747.   BRANCH MSG2
  748. LABEL MSG1
  749.   (.") "MSG # " .
  750. LABEL MSG2
  751. ;
  752.  
  753. ( DISK-ORIENTED WORDS )
  754.  
  755. : +BUF
  756.   LIT 1028            ( 1K PLUS 4 BYTES OVERHEAD, CO from defines )
  757.   + DUP LIMIT = 0BRANCH P1
  758.   DROP FIRST
  759. LABEL P1
  760.   DUP PREV @ -
  761. ;
  762.  
  763. : UPDATE             ( MARK BUFFER AS MODIFIED )
  764.   PREV @ @ LIT 0X8000 OR PREV @ !
  765. ;
  766.  
  767. : EMPTY-BUFFERS
  768.   FIRST LIMIT OVER - ERASE
  769. ;
  770.  
  771. : BUFFER
  772.   USE @ DUP >R
  773. LABEL BUF1
  774.   +BUF 0BRANCH BUF1        ( LOOP UNTIL +BUF RETURNS NONZERO )
  775.   USE ! R @ 0< 0BRANCH BUF2    ( SEE IF IT'S DIRTY <sign bit is dirty bit> )
  776.   R 2+ R @ LIT 0X7FFF AND 0 R/W    ( WRITE THIS DIRTY BUFFER )
  777. LABEL BUF2
  778.   R !
  779.   R PREV !
  780.   R> 2+
  781. ;
  782.  
  783. : BLOCK
  784.   OFFSET @ + >R PREV @ DUP @ R - DUP +
  785.   0BRANCH BLOCK1
  786. LABEL BLOCK2
  787.   +BUF 0=
  788.   0BRANCH BLOCK3
  789.   DROP R BUFFER DUP R 1 R/W 2 -
  790. LABEL BLOCK3
  791.   DUP @ R - DUP + 0= 0BRANCH BLOCK2
  792.   DUP PREV ! 
  793. LABEL BLOCK1
  794.   R> DROP 2+
  795. ;
  796.  
  797. : R/W                ( ADDR F BUFNO -- read if F=1, write if 0 )
  798.   (R/W)
  799.   
  800. ;
  801.  
  802. : FLUSH
  803.   #BUFF 1+ 0 (DO) 
  804. LABEL FLUSH1
  805.       0 BUFFER DROP 
  806.   (LOOP) FLUSH1
  807. ;
  808.  
  809. : LOAD
  810.   BLK @ >R IN @ >R 0 IN !
  811.   B/SCR * BLK !
  812.   INTERPRET
  813.   R> IN ! R> BLK !
  814. ;
  815.  
  816. : -->
  817.   (.") "--> "
  818.   ?LOADING 0 IN ! B/SCR BLK @ OVER MOD - BLK +!
  819. ;*
  820.  
  821. : '
  822.   -FIND 0= 0 ?ERROR DROP LITERAL
  823. ;*
  824.  
  825. : FORGET
  826.   CURRENT @ CONTEXT @ - LIT 24 ?ERROR
  827.   ' DUP FENCE @ < LIT 21 ?ERROR
  828.   DUP NFA DP ! LFA @ CONTEXT @ !
  829. ;
  830.  
  831. ( COMPILING WORDS )
  832.  
  833. : BACK
  834.   HERE - ,
  835. ;
  836.  
  837. : BEGIN
  838.   ?COMP HERE 1
  839. ;*
  840.  
  841. : ENDIF
  842.   ?COMP 2 ?PAIRS HERE OVER - SWAP !
  843. ;*
  844.  
  845. : THEN
  846.   ENDIF
  847. ;*
  848.  
  849. : DO
  850.   COMPILE (DO) HERE LIT 3
  851. ;*
  852.  
  853. : LOOP
  854.   LIT 3 ?PAIRS COMPILE (LOOP) BACK
  855. ;*
  856.  
  857. : +LOOP
  858.   LIT 3 ?PAIRS ?COMP COMPILE (+LOOP) BACK
  859. ;*
  860.  
  861. : UNTIL
  862.   1 ?PAIRS COMPILE 0BRANCH BACK
  863. ;*
  864.  
  865. : END
  866.   UNTIL
  867. ;*
  868.  
  869. : AGAIN
  870.   ?COMP
  871.   1 ?PAIRS COMPILE BRANCH BACK
  872. ;*
  873.  
  874. : REPEAT
  875.   ?COMP
  876.   >R >R AGAIN R> R> 2 -
  877.   ENDIF
  878. ;*
  879.  
  880. : IF
  881.   COMPILE 0BRANCH HERE 0 , 2
  882. ;*
  883.  
  884. : ELSE
  885.   2 ?PAIRS COMPILE BRANCH HERE 0 , SWAP 2 ENDIF 2
  886. ;*
  887.  
  888. : WHILE
  889.   IF 2+
  890. ;*
  891.  
  892. : SPACES
  893.   0 MAX -DUP 0BRANCH SPACES1
  894.   0 (DO) 
  895. LABEL SPACES2
  896.       SPACE 
  897.   (LOOP) SPACES2
  898. LABEL SPACES1
  899. ;
  900.  
  901. : <#
  902.   PAD HLD !
  903. ;
  904.  
  905. : #>
  906.   DROP DROP HLD @ PAD OVER -
  907. ;
  908.  
  909. : SIGN
  910.   ROT 0< 0BRANCH SIGN1
  911.   LIT '-'  HOLD
  912. LABEL SIGN1
  913. ;
  914.  
  915. : #
  916.   BASE @ M/MOD ROT LIT 9 OVER < 0BRANCH #1
  917.   LIT 7 +        ( 7 is offset to make 'A' come after '9')
  918. LABEL #1
  919.   LIT '0' + HOLD
  920. ;
  921.  
  922. : #S
  923. LABEL #S1
  924.   # 2DUP OR 0= 0BRANCH #S1
  925. ;
  926.  
  927. : D.R
  928.   >R SWAP OVER DABS <# #S SIGN #> R> OVER - SPACES TYPE
  929. ;
  930.  
  931. : .R
  932.   >R S->D R> D.R
  933. ;
  934.  
  935. : D.
  936.   0 D.R SPACE
  937. ;
  938.  
  939. : .
  940.   S->D D.
  941. ;
  942.  
  943. : ?
  944.   @ .
  945. ;
  946.  
  947. : U.
  948.   0 D.
  949. ;
  950.  
  951. : VLIST
  952.   C/L 1+ OUT !  CONTEXT @ @
  953. LABEL VLIST1            ( BEGIN )
  954.   OUT @ C/L > 0BRANCH VLIST2    ( IF )
  955.   CR
  956. LABEL VLIST2            ( THEN )
  957.   DUP ID. SPACE PFA LFA @
  958.   DUP 0= ?TERMINAL OR 0BRANCH VLIST1    ( UNTIL )
  959.   DROP
  960. ;
  961.  
  962. : .CPU
  963.   (.") "C-CODED FORTH INTERPRETER"    ( special string handling )
  964. ;
  965.  
  966. : BYE
  967.   CR (.") "EXIT FORTH" CR
  968.   0 (BYE)
  969. ;
  970.  
  971. : LIST
  972.   DECIMAL CR
  973.   DUP SCR ! (.") "SCR # " .
  974.   LIT 16 0 (DO)
  975. LABEL LIST1
  976.     CR I 3 .R SPACE
  977.     I SCR @ .LINE
  978.     ?TERMINAL 0BRANCH LIST2
  979.       LEAVE
  980. LABEL LIST2
  981.   (LOOP) LIST1
  982.   CR
  983. ;
  984.  
  985. : CASE
  986.   ?COMP CSP @ !CSP LIT 4
  987. ;*
  988.  
  989. : OF
  990.   ?COMP LIT 4 ?PAIRS
  991.   COMPILE OVER COMPILE = COMPILE 0BRANCH 
  992.   HERE 0 ,
  993.   COMPILE DROP
  994.   LIT 5
  995. ;*
  996.  
  997. : ENDOF
  998.   ?COMP
  999.   LIT 5 ?PAIRS
  1000.   COMPILE BRANCH
  1001.   HERE 0 ,
  1002.   SWAP 2 ENDIF LIT 4
  1003. ;*
  1004.  
  1005. : ENDCASE
  1006.   ?COMP
  1007.   LIT 4 ?PAIRS
  1008.   COMPILE DROP
  1009. LABEL ENDC1            ( BEGIN )
  1010.   SP@ CSP @ != 0BRANCH ENDC2    ( WHILE )
  1011.   2 ENDIF
  1012.   BRANCH ENDC1            ( REPEAT )
  1013. LABEL ENDC2
  1014.   CSP !
  1015. ;*
  1016.  
  1017. : \            ( REMAINER OF THE LINE IS A COMMENT )
  1018.   ?LOADING
  1019.   IN @ C/L / 1+ C/L * IN !
  1020. ;*
  1021.  
  1022. : ALIAS        ( usage: ALIAS NEW OLD; makes already-compiled references )
  1023.         ( to OLD refer to NEW. Restrictions: OLD must have been a )
  1024.         ( colon-definition, and it must not have been of the form )
  1025.         ( { : OLD ; } where the first word of the PFA is ;S .     )
  1026.   ' CFA
  1027.   ' DUP
  1028.   2 - @ LIT DOCOL != LIT 27 ?ERROR    ( ERROR IF NOT A COLON DEFINITION )
  1029.   DUP @    LIT ;S = LIT 28 ?ERROR        ( MAKE SURE ;S IS NOT THE FIRST WORD )
  1030.   DUP >R ! LIT ;S R> 2+ !
  1031. ;
  1032.  
  1033. : REFORTH        ( GET & EXECUTE ONE FORTH LINE <PERHAPS A NUMBER> )
  1034.   IN @ >R BLK @ >R
  1035.   0 IN ! 0 BLK !
  1036.   QUERY INTERPRET
  1037.   R> BLK ! R> IN !
  1038. ;
  1039.  
  1040.  
  1041. ( The vocabulary word FORTH will be compiled after the dictionary is read,
  1042.   with a pointer to the last word in the dictionary, which will be itself. )
  1043.